home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / kcl / akcl / kcl.lha / c / format.c < prev    next >
C/C++ Source or Header  |  1987-06-04  |  43KB  |  2,083 lines
  1. /*
  2. (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984.  All rights reserved.
  3. Copying of this file is authorized to users who have executed the true and
  4. proper "License Agreement for Kyoto Common LISP" with SIGLISP.
  5. */
  6.  
  7. /*
  8.     format.c
  9. */
  10.  
  11. #include "include.h"
  12.  
  13. object siVindent_formatted_output;
  14.  
  15. object fmt_stream;
  16. int ctl_origin;
  17. int ctl_index;
  18. int ctl_end;
  19. object *fmt_base;
  20. int fmt_index;
  21. int fmt_end;
  22. int *fmt_jmp_buf;
  23. int fmt_indents;
  24. object fmt_string;
  25.  
  26. #define    ctl_string    (fmt_string->st.st_self + ctl_origin)
  27.  
  28. #define    fmt_old        object old_fmt_stream; \
  29.             int old_ctl_origin; \
  30.             int old_ctl_index; \
  31.             int old_ctl_end; \
  32.             object *old_fmt_base; \
  33.             int old_fmt_index; \
  34.             int old_fmt_end; \
  35.             int *old_fmt_jmp_buf; \
  36.             int old_fmt_indents; \
  37.             object old_fmt_string
  38. #define    fmt_save    old_fmt_stream = fmt_stream; \
  39.             old_ctl_origin = ctl_origin; \
  40.             old_ctl_index = ctl_index; \
  41.             old_ctl_end = ctl_end; \
  42.             old_fmt_base = fmt_base; \
  43.             old_fmt_index = fmt_index; \
  44.             old_fmt_end = fmt_end; \
  45.             old_fmt_jmp_buf = fmt_jmp_buf; \
  46.             old_fmt_indents = fmt_indents; \
  47.             old_fmt_string = fmt_string
  48. #define    fmt_restore    fmt_stream = old_fmt_stream; \
  49.             ctl_origin = old_ctl_origin; \
  50.             ctl_index = old_ctl_index; \
  51.             ctl_end = old_ctl_end; \
  52.             fmt_base = old_fmt_base; \
  53.             fmt_index = old_fmt_index; \
  54.             fmt_end = old_fmt_end; \
  55.             fmt_jmp_buf = old_fmt_jmp_buf; \
  56.             fmt_indents = old_fmt_indents; \
  57.             fmt_string = old_fmt_string
  58. #define    fmt_restore1    fmt_stream = old_fmt_stream; \
  59.             ctl_origin = old_ctl_origin; \
  60.             ctl_index = old_ctl_index; \
  61.             ctl_end = old_ctl_end; \
  62.             fmt_jmp_buf = old_fmt_jmp_buf; \
  63.             fmt_indents = old_fmt_indents; \
  64.             fmt_string = old_fmt_string
  65.  
  66.  
  67. object fmt_temporary_stream;
  68. object fmt_temporary_string;
  69.  
  70. int fmt_nparam;
  71. #define    INT    1
  72. #define    CHAR    2
  73. struct {
  74.     int fmt_param_type;
  75.     int fmt_param_value;
  76. } fmt_param[100];
  77.  
  78.  
  79. char *fmt_big_numeral[] = {
  80.     "thousand",
  81.     "million",
  82.     "billion",
  83.     "trillion",
  84.     "quadrillion",
  85.     "quintillion",
  86.     "sextillion",
  87.     "septillion",
  88.     "octillion"
  89. };
  90.  
  91. char *fmt_numeral[] = {
  92.     "zero", "one", "two", "three", "four",
  93.     "five", "six", "seven", "eight", "nine",
  94.     "ten", "eleven", "twelve", "thirteen", "fourteen",
  95.     "fifteen", "sixteen", "seventeen", "eighteen", "nineteen",
  96.     "zero", "ten", "twenty", "thirty", "forty",
  97.     "fifty", "sixty", "seventy", "eighty", "ninety"
  98. };
  99.  
  100. char *fmt_ordinal[] = {
  101.     "zeroth", "first", "second", "third", "fourth",
  102.     "fifth", "sixth", "seventh", "eighth", "ninth",
  103.     "tenth", "eleventh", "twelfth", "thirteenth", "fourteenth",
  104.     "fifteenth", "sixteenth", "seventeenth", "eighteenth", "nineteenth",
  105.     "zeroth", "tenth", "twentieth", "thirtieth", "fortieth",
  106.     "fiftieth", "sixtieth", "seventieth", "eightieth", "ninetieth"
  107. };
  108.  
  109.  
  110. int fmt_spare_spaces;
  111. int fmt_line_length;
  112.  
  113.  
  114. int
  115. fmt_tempstr(s)
  116. int s;
  117. {
  118.     return(fmt_temporary_string->st.st_self[s]);
  119. }
  120.  
  121. ctl_advance()
  122. {
  123.     if (ctl_index >= ctl_end)
  124.         fmt_error("unexpected end of control string");
  125.     return(ctl_string[ctl_index++]);
  126. }
  127.  
  128. object
  129. fmt_advance()
  130. {
  131.     if (fmt_index >= fmt_end)
  132.         fmt_error("arguments exhausted");
  133.     return(fmt_base[fmt_index++]);
  134. }
  135.  
  136.  
  137. format(fmt_stream0, ctl_origin0, ctl_end0)
  138. object fmt_stream0;
  139. int ctl_origin0;
  140. int ctl_end0;
  141. {
  142.     int c, i, n;
  143.     bool colon, atsign;
  144.     object x;
  145.  
  146.     fmt_stream = fmt_stream0;
  147.     ctl_origin = ctl_origin0;
  148.     ctl_index = 0;
  149.     ctl_end = ctl_end0;
  150.  
  151. LOOP:
  152.     if (ctl_index >= ctl_end)
  153.         return;
  154.     if ((c = ctl_advance()) != '~') {
  155.         writec_stream(c, fmt_stream);
  156.         goto LOOP;
  157.     }
  158.     n = 0;
  159.     for (;;) {
  160.         switch (c = ctl_advance()) {
  161.         case ',':
  162.             fmt_param[n].fmt_param_type = NULL;
  163.             break;
  164.  
  165.         case '0':  case '1':  case '2':  case '3':  case '4':
  166.         case '5':  case '6':  case '7':  case '8':  case '9':
  167.         DIGIT:
  168.             i = 0;
  169.             do {
  170.                 i = i*10 + (c - '0');
  171.                 c = ctl_advance();
  172.             } while (isDigit(c));
  173.             fmt_param[n].fmt_param_type = INT;
  174.             fmt_param[n].fmt_param_value = i;
  175.             break;
  176.  
  177.         case '+':
  178.             c = ctl_advance();
  179.             if (!isDigit(c))
  180.                 fmt_error("digit expected");
  181.             goto DIGIT;
  182.  
  183.         case '-':
  184.             c = ctl_advance();
  185.             if (!isDigit(c))
  186.                 fmt_error("digit expected");
  187.             i = 0;
  188.             do {
  189.                 i = i*10 + (c - '0');
  190.                 c = ctl_advance();
  191.             } while (isDigit(c));
  192.             fmt_param[n].fmt_param_type = INT;
  193.             fmt_param[n].fmt_param_value = -i;
  194.             break;
  195.  
  196.         case '\'':
  197.             fmt_param[n].fmt_param_type = CHAR;
  198.             fmt_param[n].fmt_param_value = ctl_advance();
  199.             c = ctl_advance();
  200.             break;
  201.  
  202.         case 'v':  case 'V':
  203.             x = fmt_advance();
  204.             if (type_of(x) == t_fixnum) {
  205.                 fmt_param[n].fmt_param_type = INT;
  206.                 fmt_param[n].fmt_param_value = fix(x);
  207.             } else if (type_of(x) == t_character) {
  208.                 fmt_param[n].fmt_param_type = CHAR;
  209.                 fmt_param[n].fmt_param_value = x->ch.ch_code;
  210.             } else
  211.                 fmt_error("illegal V parameter");
  212.             c = ctl_advance();
  213.             break;
  214.  
  215.         case '#':
  216.             fmt_param[n].fmt_param_type = INT;
  217.             fmt_param[n].fmt_param_value = fmt_end - fmt_index;
  218.             c = ctl_advance();
  219.             break;
  220.  
  221.         default:
  222.             if (n > 0)
  223.                 fmt_error("illegal ,");
  224.             else
  225.                 goto DIRECTIVE;
  226.         }
  227.         n++;
  228.         if (c != ',')
  229.             break;
  230.     }
  231.  
  232. DIRECTIVE:
  233.     colon = atsign = FALSE;
  234.     if (c == ':') {
  235.         colon = TRUE;
  236.         c = ctl_advance();
  237.     }
  238.     if (c == '@') {
  239.         atsign = TRUE;
  240.         c = ctl_advance();
  241.     }
  242.     fmt_nparam = n;
  243.     switch (c) {
  244.     case 'a':  case 'A':
  245.         fmt_ascii(colon, atsign);
  246.         break;
  247.  
  248.     case 's':  case 'S':
  249.         fmt_S_expression(colon, atsign);
  250.         break;
  251.  
  252.     case 'd':  case 'D':
  253.         fmt_decimal(colon, atsign);
  254.         break;
  255.  
  256.     case 'b':  case 'B':
  257.         fmt_binary(colon, atsign);
  258.         break;
  259.  
  260.     case 'o':  case 'O':
  261.         fmt_octal(colon, atsign);
  262.         break;
  263.  
  264.     case 'x':  case 'X':
  265.         fmt_hexadecimal(colon, atsign);
  266.         break;
  267.  
  268.     case 'r':  case 'R':
  269.         fmt_radix(colon, atsign);
  270.         break;
  271.  
  272.     case 'p':  case 'P':
  273.         fmt_plural(colon, atsign);
  274.         break;
  275.  
  276.     case 'c':  case 'C':
  277.         fmt_character(colon, atsign);
  278.         break;
  279.  
  280.     case 'f':  case 'F':
  281.         fmt_fix_float(colon, atsign);
  282.         break;
  283.  
  284.     case 'e':  case 'E':
  285.         fmt_exponential_float(colon, atsign);
  286.         break;
  287.  
  288.     case 'g':  case 'G':
  289.         fmt_general_float(colon, atsign);
  290.         break;
  291.  
  292.     case '$':
  293.         fmt_dollars_float(colon, atsign);
  294.         break;
  295.  
  296.     case '%':
  297.         fmt_percent(colon, atsign);
  298.         break;
  299.  
  300.     case '&':
  301.         fmt_ampersand(colon, atsign);
  302.         break;
  303.  
  304.     case '|':
  305.         fmt_bar(colon, atsign);
  306.         break;
  307.  
  308.     case '~':
  309.         fmt_tilde(colon, atsign);
  310.         break;
  311.  
  312.     case '\n':
  313.         fmt_newline(colon, atsign);
  314.         break;
  315.  
  316.     case 't':  case 'T':
  317.         fmt_tabulate(colon, atsign);
  318.         break;
  319.  
  320.     case '*':
  321.         fmt_asterisk(colon, atsign);
  322.         break;
  323.  
  324.     case '?':
  325.         fmt_indirection(colon, atsign);
  326.         break;
  327.  
  328.     case '(':
  329.         fmt_case(colon, atsign);
  330.         break;
  331.  
  332.     case '[':
  333.         fmt_conditional(colon, atsign);
  334.         break;
  335.  
  336.     case '{':
  337.         fmt_iteration(colon, atsign);
  338.         break;
  339.  
  340.     case '<':
  341.         fmt_justification(colon, atsign);
  342.         break;
  343.  
  344.     case '^':
  345.         fmt_up_and_out(colon, atsign);
  346.         break;
  347.  
  348.     case ';':
  349.         fmt_semicolon(colon, atsign);
  350.         break;
  351.  
  352.     default:
  353.         fmt_error("illegal directive");
  354.     }
  355.     goto LOOP;
  356. }
  357.  
  358.  
  359.  
  360. fmt_skip()
  361. {
  362.     int c, level = 0;
  363.     
  364. LOOP:
  365.     if (ctl_advance() != '~')
  366.         goto LOOP;
  367.     for (;;)
  368.         switch (c = ctl_advance()) {
  369.         case '\'':
  370.             ctl_advance();
  371.  
  372.         case ',':
  373.         case '0':  case '1':  case '2':  case '3':  case '4':
  374.         case '5':  case '6':  case '7':  case '8':  case '9':
  375.         case '+':
  376.         case '-':
  377.         case 'v':  case 'V':
  378.         case '#':
  379.         case ':':  case '@':
  380.             continue;
  381.  
  382.         default:
  383.             goto DIRECTIVE;
  384.         }
  385.  
  386. DIRECTIVE:
  387.     switch (c) {
  388.     case '(':  case '[':  case '<':  case '{':
  389.         level++;
  390.         break;
  391.  
  392.     case ')':  case ']':  case '>':  case '}':
  393.         if (level == 0)
  394.             return(ctl_index);
  395.         else
  396.             --level;
  397.         break;
  398.  
  399.     case ';':
  400.         if (level == 0)
  401.             return(ctl_index);
  402.         break;
  403.     }
  404.     goto LOOP;
  405. }
  406.  
  407.  
  408. fmt_max_param(n)
  409. {
  410.     if (fmt_nparam > n)
  411.         fmt_error("too many parameters");
  412. }
  413.  
  414. fmt_not_colon(colon)
  415. bool colon;
  416. {
  417.     if (colon)
  418.         fmt_error("illegal :");
  419. }
  420.  
  421. fmt_not_atsign(atsign)
  422. bool atsign;
  423. {
  424.     if (atsign)
  425.         fmt_error("illegal @");
  426. }
  427.  
  428. fmt_not_colon_atsign(colon, atsign)
  429. bool colon, atsign;
  430. {
  431.     if (colon && atsign)
  432.         fmt_error("illegal :@");
  433. }
  434.  
  435. fmt_set_param(i, p, t, v)
  436. int i, *p, t, v;
  437. {
  438.     if (i >= fmt_nparam || fmt_param[i].fmt_param_type == NULL)
  439.         *p = v;
  440.     else if (fmt_param[i].fmt_param_type != t)
  441.         fmt_error("illegal parameter type");
  442.     else
  443.         *p = fmt_param[i].fmt_param_value;
  444. }    
  445.  
  446.  
  447. fmt_ascii(colon, atsign)
  448. {
  449.     int mincol, colinc, minpad, padchar;
  450.     object x;
  451.     int c, l, i;
  452.  
  453.     fmt_max_param(4);
  454.     fmt_set_param(0, &mincol, INT, 0);
  455.     fmt_set_param(1, &colinc, INT, 1);
  456.     fmt_set_param(2, &minpad, INT, 0);
  457.     fmt_set_param(3, &padchar, CHAR, ' ');
  458.  
  459.     fmt_temporary_string->st.st_fillp = 0;
  460.     fmt_temporary_stream->sm.sm_int0 = file_column(fmt_stream);
  461.     fmt_temporary_stream->sm.sm_int1 = file_column(fmt_stream);
  462.     x = fmt_advance();
  463.     if (colon && x == Cnil)
  464.         writestr_stream("()", fmt_temporary_stream);
  465.     else if (mincol == 0 && minpad == 0) {
  466.         princ(x, fmt_stream);
  467.         return;
  468.     } else
  469.         princ(x, fmt_temporary_stream);
  470.     l = fmt_temporary_string->st.st_fillp;
  471.     for (i = minpad;  l + i < mincol;  i += colinc)
  472.         ;
  473.     if (!atsign) {
  474.         write_string(fmt_temporary_string, fmt_stream);
  475.         while (i-- > 0)
  476.             writec_stream(padchar, fmt_stream);
  477.     } else {
  478.         while (i-- > 0)
  479.             writec_stream(padchar, fmt_stream);
  480.         write_string(fmt_temporary_string, fmt_stream);
  481.     }
  482. }
  483.  
  484. fmt_S_expression(colon, atsign)
  485. {
  486.     int mincol, colinc, minpad, padchar;
  487.     object x;
  488.     int c, l, i;
  489.  
  490.     fmt_max_param(4);
  491.     fmt_set_param(0, &mincol, INT, 0);
  492.     fmt_set_param(1, &colinc, INT, 1);
  493.     fmt_set_param(2, &minpad, INT, 0);
  494.     fmt_set_param(3, &padchar, CHAR, ' ');
  495.  
  496.     fmt_temporary_string->st.st_fillp = 0;
  497.     fmt_temporary_stream->sm.sm_int0 = file_column(fmt_stream);
  498.     fmt_temporary_stream->sm.sm_int1 = file_column(fmt_stream);
  499.     x = fmt_advance();
  500.     if (colon && x == Cnil)
  501.         writestr_stream("()", fmt_temporary_stream);
  502.     else if (mincol == 0 && minpad == 0) {
  503.         prin1(x, fmt_stream);
  504.         return;
  505.     } else
  506.         prin1(x, fmt_temporary_stream);
  507.     l = fmt_temporary_string->st.st_fillp;
  508.     for (i = minpad;  l + i < mincol;  i += colinc)
  509.         ;
  510.     if (!atsign) {
  511.         write_string(fmt_temporary_string, fmt_stream);
  512.         while (i-- > 0)
  513.             writec_stream(padchar, fmt_stream);
  514.     } else {
  515.         while (i-- > 0)
  516.             writec_stream(padchar, fmt_stream);
  517.         write_string(fmt_temporary_string, fmt_stream);
  518.     }
  519. }
  520.  
  521. fmt_decimal(colon, atsign)
  522. {
  523.     int mincol, padchar, commachar;
  524.  
  525.     fmt_max_param(3);
  526.     fmt_set_param(0, &mincol, INT, 0);
  527.     fmt_set_param(1, &padchar, CHAR, ' ');
  528.     fmt_set_param(2, &commachar, CHAR, ',');
  529.     fmt_integer(fmt_advance(), colon, atsign,
  530.             10, mincol, padchar, commachar);
  531. }
  532.  
  533. fmt_binary(colon, atsign)
  534. {
  535.     int mincol, padchar, commachar;
  536.  
  537.     fmt_max_param(3);
  538.     fmt_set_param(0, &mincol, INT, 0);
  539.     fmt_set_param(1, &padchar, CHAR, ' ');
  540.     fmt_set_param(2, &commachar, CHAR, ',');
  541.     fmt_integer(fmt_advance(), colon, atsign,
  542.             2, mincol, padchar, commachar);
  543. }
  544.  
  545. fmt_octal(colon, atsign)
  546. {
  547.     int mincol, padchar, commachar;
  548.  
  549.     fmt_max_param(3);
  550.     fmt_set_param(0, &mincol, INT, 0);
  551.     fmt_set_param(1, &padchar, CHAR, ' ');
  552.     fmt_set_param(2, &commachar, CHAR, ',');
  553.     fmt_integer(fmt_advance(), colon, atsign,
  554.             8, mincol, padchar, commachar);
  555. }
  556.  
  557. fmt_hexadecimal(colon, atsign)
  558. {
  559.     int mincol, padchar, commachar;
  560.  
  561.     fmt_max_param(3);
  562.     fmt_set_param(0, &mincol, INT, 0);
  563.     fmt_set_param(1, &padchar, CHAR, ' ');
  564.     fmt_set_param(2, &commachar, CHAR, ',');
  565.     fmt_integer(fmt_advance(), colon, atsign,
  566.             16, mincol, padchar, commachar);
  567. }
  568.  
  569. fmt_radix(colon, atsign)
  570. {
  571.     int radix, mincol, padchar, commachar;
  572.     object x;
  573.     int i, j, k;
  574.     int s, t;
  575.     bool b;
  576.     extern (*write_ch_fun)(), writec_PRINTstream();
  577.  
  578.     if (fmt_nparam == 0) {
  579.         x = fmt_advance();
  580.         check_type_integer(&x);
  581.         if (atsign) {
  582.             if (type_of(x) == t_fixnum)
  583.                 i = fix(x);
  584.             else
  585.                 i = -1;
  586.             if (!colon && (i <= 0 || i >= 4000) ||
  587.                 colon && (i <= 0 || i >= 5000)) {
  588.                 fmt_integer(x, FALSE, FALSE, 10, 0, ' ', ',');
  589.                 return;
  590.             }
  591.             fmt_roman(i/1000, 'M', '*', '*', colon);
  592.             fmt_roman(i%1000/100, 'C', 'D', 'M', colon);
  593.             fmt_roman(i%100/10, 'X', 'L', 'C', colon);
  594.             fmt_roman(i%10, 'I', 'V', 'X', colon);
  595.             return;
  596.         }
  597.         fmt_temporary_string->st.st_fillp = 0;
  598.         fmt_temporary_stream->sm.sm_int0 = file_column(fmt_stream);
  599.         fmt_temporary_stream->sm.sm_int1 = file_column(fmt_stream);
  600.         PRINTstream = fmt_temporary_stream;
  601.         PRINTradix = FALSE;
  602.         PRINTbase = 10;
  603.         write_ch_fun = writec_PRINTstream;
  604.         write_object(x, 0);
  605.         s = 0;
  606.         i = fmt_temporary_string->st.st_fillp;
  607.         if (i == 1 && fmt_tempstr(s) == '0') {
  608.             writestr_stream("zero", fmt_stream);
  609.             if (colon)
  610.                 writestr_stream("th", fmt_stream);
  611.             return;
  612.         } else if (fmt_tempstr(s) == '-') {
  613.             writestr_stream("minus ", fmt_stream);
  614.             --i;
  615.             s++;
  616.         }
  617.         t = fmt_temporary_string->st.st_fillp;
  618.         for (;;)
  619.             if (fmt_tempstr(--t) != '0')
  620.                 break;
  621.         for (b = FALSE;  i > 0;  i -= j) {
  622.             b = fmt_nonillion(s, j = (i+29)%30+1, b,
  623.                       i<=30&&colon, t);
  624.             s += j;
  625.             if (b && i > 30) {
  626.                 for (k = (i - 1)/30;  k > 0;  --k)
  627.                     writestr_stream(" nonillion",
  628.                             fmt_stream);
  629.                 if (colon && s > t)
  630.                     writestr_stream("th", fmt_stream);
  631.             }
  632.         }
  633.         return;
  634.     }
  635.     fmt_max_param(4);
  636.     fmt_set_param(0, &radix, INT, 10);
  637.     fmt_set_param(1, &mincol, INT, 0);
  638.     fmt_set_param(2, &padchar, CHAR, ' ');
  639.     fmt_set_param(3, &commachar, CHAR, ',');
  640.     x = fmt_advance();
  641.     check_type_integer(&x);
  642.     if (radix < 0 || radix > 36) {
  643.         vs_push(make_fixnum(radix));
  644.         FEerror("~D is illegal as a radix.", 1, vs_head);
  645.     }
  646.     fmt_integer(x, colon, atsign, radix, mincol, padchar, commachar);
  647. }    
  648.  
  649. fmt_integer(x, colon, atsign, radix, mincol, padchar, commachar)
  650. object x;
  651. {
  652.     int l, l1;
  653.     int s;
  654.     extern (*write_ch_fun)(), writec_PRINTstream();
  655.  
  656.     if (type_of(x) != t_fixnum && type_of(x) != t_bignum) {
  657.         fmt_temporary_string->st.st_fillp = 0;
  658.         fmt_temporary_stream->sm.sm_int0 = file_column(fmt_stream);
  659.         fmt_temporary_stream->sm.sm_int1 = file_column(fmt_stream);
  660.         setupPRINTdefault(x);
  661.         PRINTstream = fmt_temporary_stream;
  662.         PRINTescape = FALSE;
  663.         PRINTbase = radix;
  664.         write_ch_fun = writec_PRINTstream;
  665.         write_object(x, 0);
  666.         cleanupPRINT();
  667.         l = fmt_temporary_string->st.st_fillp;
  668.         mincol -= l;
  669.         while (mincol-- > 0)
  670.             writec_stream(padchar, fmt_stream);
  671.         for (s = 0;  l > 0;  --l, s++)
  672.             writec_stream(fmt_tempstr(s), fmt_stream);
  673.         return;
  674.     }
  675.     fmt_temporary_string->st.st_fillp = 0;
  676.     fmt_temporary_stream->sm.sm_int0 = file_column(fmt_stream);
  677.     fmt_temporary_stream->sm.sm_int1 = file_column(fmt_stream);
  678.     PRINTstream = fmt_temporary_stream;
  679.     PRINTradix = FALSE;
  680.     PRINTbase = radix;
  681.     write_ch_fun = writec_PRINTstream;
  682.     write_object(x, 0);
  683.     l = l1 = fmt_temporary_string->st.st_fillp;
  684.     s = 0;
  685.     if (fmt_tempstr(s) == '-')
  686.         --l1;
  687.     mincol -= l;
  688.     if (colon)
  689.         mincol -= (l1 - 1)/3;
  690.     if (atsign && fmt_tempstr(s) != '-')
  691.         --mincol;
  692.     while (mincol-- > 0)
  693.         writec_stream(padchar, fmt_stream);
  694.     if (fmt_tempstr(s) == '-') {
  695.         s++;
  696.         writec_stream('-', fmt_stream);
  697.     } else if (atsign)
  698.         writec_stream('+', fmt_stream);
  699.     while (l1-- > 0) {
  700.         writec_stream(fmt_tempstr(s++), fmt_stream);
  701.         if (colon && l1 > 0 && l1%3 == 0)
  702.             writec_stream(commachar, fmt_stream);
  703.     }
  704. }
  705.  
  706. fmt_nonillion(s, i, b, o, t)
  707. int s, t;
  708. int i;
  709. bool b, o;
  710. {
  711.     int j;
  712.  
  713.     for (;  i > 3;  i -= j) {
  714.         b = fmt_thousand(s, j = (i+2)%3+1, b, FALSE, t);
  715.         if (j != 3 || fmt_tempstr(s) != '0' ||
  716.             fmt_tempstr(s+1) != '0' || fmt_tempstr(s+2) != '0') {
  717.             writec_stream(' ', fmt_stream);
  718.             writestr_stream(fmt_big_numeral[(i - 1)/3 - 1],
  719.                     fmt_stream);
  720.             s += j;
  721.             if (o && s > t)
  722.                 writestr_stream("th", fmt_stream);
  723.         } else
  724.             s += j;
  725.     }
  726.     return(fmt_thousand(s, i, b, o, t));
  727. }        
  728.  
  729. fmt_thousand(s, i, b, o, t)
  730. int s, t;
  731. int i;
  732. bool b, o;
  733. {
  734.     if (i == 3 && fmt_tempstr(s) > '0') {
  735.         if (b)
  736.             writec_stream(' ', fmt_stream);
  737.         fmt_write_numeral(s, 0);
  738.         writestr_stream(" hundred", fmt_stream);
  739.         --i;
  740.         s++;
  741.         b = TRUE;
  742.         if (o & s > t)
  743.             writestr_stream("th", fmt_stream);
  744.     }
  745.     if (i == 3) {
  746.         --i;
  747.         s++;
  748.     }
  749.     if (i == 2 && fmt_tempstr(s) > '0') {
  750.         if (b)
  751.             writec_stream(' ', fmt_stream);
  752.         if (fmt_tempstr(s) == '1') {
  753.             if (o && s + 2 > t)
  754.                 fmt_write_ordinal(++s, 10);
  755.             else
  756.                 fmt_write_numeral(++s, 10);
  757.             return(TRUE);
  758.         } else {
  759.             if (o && s + 1 > t)
  760.                 fmt_write_ordinal(s, 20);
  761.             else
  762.                 fmt_write_numeral(s, 20);
  763.             s++;
  764.             if (fmt_tempstr(s) > '0') {
  765.                 writec_stream('-', fmt_stream);
  766.                 if (o && s + 1 > t)
  767.                     fmt_write_ordinal(s, 0);
  768.                 else
  769.                     fmt_write_numeral(s, 0);
  770.             }
  771.             return(TRUE);
  772.         }
  773.     }
  774.     if (i == 2)
  775.         s++;
  776.     if (fmt_tempstr(s) > '0') {
  777.         if (b)
  778.             writec_stream(' ', fmt_stream);
  779.         if (o && s + 1 > t)
  780.             fmt_write_ordinal(s, 0);
  781.         else
  782.             fmt_write_numeral(s, 0);
  783.         return(TRUE);
  784.     }
  785.     return(b);
  786. }
  787.     
  788. fmt_write_numeral(s, i)
  789. int s, i;
  790. {
  791.     writestr_stream(fmt_numeral[fmt_tempstr(s) - '0' + i], fmt_stream);
  792. }
  793.  
  794. fmt_write_ordinal(s, i)
  795. int s, i;
  796. {
  797.     writestr_stream(fmt_ordinal[fmt_tempstr(s) - '0' + i], fmt_stream);
  798. }
  799.  
  800. fmt_roman(i, one, five, ten, colon)
  801. {
  802.     int j;
  803.  
  804.     if (i == 0)
  805.         return;
  806.     if (!colon && i < 4 || colon && i < 5)
  807.         for (j = 0;  j < i;  j++)
  808.             writec_stream(one, fmt_stream);
  809.     else if (!colon && i == 4) {
  810.         writec_stream(one, fmt_stream);
  811.         writec_stream(five, fmt_stream);
  812.     } else if (!colon && i < 9 || colon) {
  813.         writec_stream(five, fmt_stream);
  814.         for (j = 5;  j < i;  j++)
  815.             writec_stream(one, fmt_stream);
  816.     } else if (!colon && i == 9) {
  817.         writec_stream(one, fmt_stream);
  818.         writec_stream(ten, fmt_stream);
  819.     }
  820. }
  821.  
  822. fmt_plural(colon, atsign)
  823. {
  824.     fmt_max_param(0);
  825.     if (colon) {
  826.         if (fmt_index == 0)
  827.             fmt_error("can't back up");
  828.         --fmt_index;
  829.     }
  830.     if (eql(fmt_advance(), make_fixnum(1)))
  831.         if (atsign)
  832.             writec_stream('y', fmt_stream);
  833.         else
  834.             ;
  835.     else
  836.         if (atsign)
  837.             writestr_stream("ies", fmt_stream);
  838.         else
  839.             writec_stream('s', fmt_stream);
  840. }
  841.  
  842. fmt_character(colon, atsign)
  843. {
  844.     object x;
  845.     int i;
  846.  
  847.     fmt_max_param(0);
  848.     fmt_temporary_string->st.st_fillp = 0;
  849.     fmt_temporary_stream->sm.sm_int0 = 0;
  850.     fmt_temporary_stream->sm.sm_int1 = 0;
  851.     x = fmt_advance();
  852.     check_type_character(&x);
  853.     prin1(x, fmt_temporary_stream);
  854.     if (!colon && atsign)
  855.         i = 0;
  856.     else
  857.         i = 2;
  858.     for (;  i < fmt_temporary_string->st.st_fillp;  i++)
  859.         writec_stream(fmt_tempstr(i), fmt_stream);
  860. }
  861.  
  862. fmt_fix_float(colon, atsign)
  863. {
  864.     int w, d, k, overflowchar, padchar;
  865.     double f;
  866.     int sign;
  867.     char buff[256], *b, buff1[256];
  868.     int exp;
  869.     int i, j;
  870.     object x;
  871.     int n, m;
  872.     vs_mark;
  873.  
  874.     b = buff1 + 1;
  875.  
  876.     fmt_not_colon(colon);
  877.     fmt_max_param(5);
  878.     fmt_set_param(0, &w, INT, 0);
  879.     if (w < 0)
  880.         fmt_error("illegal width");
  881.     fmt_set_param(0, &w, INT, -1);
  882.     fmt_set_param(1, &d, INT, 0);
  883.     if (d < 0)
  884.         fmt_error("illegal number of digits");
  885.     fmt_set_param(1, &d, INT, -1);
  886.     fmt_set_param(2, &k, INT, 0);
  887.     fmt_set_param(3, &overflowchar, CHAR, -1);
  888.     fmt_set_param(4, &padchar, CHAR, ' ');
  889.  
  890.     x = fmt_advance();
  891.     if (type_of(x) == t_fixnum ||
  892.         type_of(x) == t_bignum ||
  893.         type_of(x) == t_ratio) {
  894.         x = make_shortfloat((shortfloat)number_to_double(x));
  895.         vs_push(x);
  896.     }
  897.     if (type_of(x) == t_complex) {
  898.         if (w < 0)
  899.             prin1(x, fmt_stream);
  900.         else {
  901.             fmt_nparam = 1;
  902.             --fmt_index;
  903.             fmt_decimal(colon, atsign);
  904.         }
  905.         vs_reset;
  906.         return;
  907.     }
  908.     if (type_of(x) == t_longfloat)
  909.         n = 16;
  910.     else
  911.         n = 7;
  912.     f = number_to_double(x);
  913.     edit_double(n, f, &sign, buff, &exp);
  914.     if (exp + k > 100 || exp + k < -100 || d > 100) {
  915.         prin1(x, fmt_stream);
  916.         vs_reset;
  917.         return;
  918.     }
  919.     if (d >= 0)
  920.         m = d + exp + k + 1;
  921.     else if (w >= 0) {
  922.         if (exp + k >= 0)
  923.             m = w - 1;
  924.         else
  925.             m = w + exp + k - 2;
  926.         if (sign < 0 || atsign)
  927.             --m;
  928.         if (m == 0)
  929.             m = 1;
  930.     } else
  931.         m = n;
  932.     if (m <= 0) {
  933.         if (m == 0 && buff[0] >= '5') {
  934.             exp++;
  935.             n = m = 1;
  936.             buff[0] = '1';
  937.         } else
  938.             n = m = 0;
  939.     } else if (m < n) {
  940.         n = m;
  941.         edit_double(n, f, &sign, buff, &exp);
  942.     }
  943.     while (n >= 0)
  944.         if (buff[n - 1] == '0')
  945.             --n;
  946.         else
  947.             break;
  948.     exp += k;
  949.     j = 0;
  950.     if (exp >= 0) {
  951.         for (i = 0;  i <= exp;  i++)
  952.             b[j++] = i < n ? buff[i] : '0';
  953.         b[j++] = '.';
  954.         if (d >= 0)
  955.             for (m = i + d;  i < m;  i++)
  956.                 b[j++] = i < n ? buff[i] : '0';
  957.         else
  958.             for (;  i < n;  i++)
  959.                 b[j++] = buff[i];
  960.     } else {
  961.         b[j++] = '.';
  962.         if (d >= 0) {
  963.             for (i = 0;  i < (-exp) - 1 && i < d;  i++)
  964.                 b[j++] = '0';
  965.             for (m = d - i, i = 0;  i < m;  i++)
  966.                 b[j++] = i < n ? buff[i] : '0';
  967.         } else if (n > 0) {
  968.             for (i = 0;  i < (-exp) - 1;  i++)
  969.                 b[j++] = '0';
  970.             for (i = 0;  i < n;  i++)
  971.                 b[j++] = buff[i];
  972.         }
  973.     }
  974.     b[j] = '\0';
  975.     if (w >= 0) {
  976.         if (sign < 0 || atsign)
  977.             --w;
  978.         if (j > w && overflowchar >= 0)
  979.             goto OVER;
  980.         if (j < w && b[j-1] == '.') {
  981.             b[j++] = '0';
  982.             b[j] = '\0';
  983.         }
  984.         if (j < w && b[0] == '.') {
  985.             *--b = '0';
  986.             j++;
  987.         }
  988.         for (i = j;  i < w;  i++)
  989.             writec_stream(padchar, fmt_stream);
  990.     } else {
  991.         if (b[0] == '.') {
  992.             *--b = '0';
  993.             j++;
  994.         }
  995.         if (d < 0 && b[j-1] == '.') {
  996.             b[j++] = '0';
  997.             b[j] = '\0';
  998.         }
  999.     }
  1000.     if (sign < 0)
  1001.         writec_stream('-', fmt_stream);
  1002.     else if (atsign)
  1003.         writec_stream('+', fmt_stream);
  1004.     writestr_stream(b, fmt_stream);
  1005.     vs_reset;
  1006.     return;
  1007.  
  1008. OVER:
  1009.     fmt_set_param(0, &w, INT, 0);
  1010.     for (i = 0;  i < w;  i++)
  1011.         writec_stream(overflowchar, fmt_stream);
  1012.     vs_reset;
  1013.     return;
  1014. }
  1015.  
  1016. int
  1017. fmt_exponent_length(e)
  1018. {
  1019.     int i;
  1020.  
  1021.     if (e == 0)
  1022.         return(1);
  1023.     if (e < 0)
  1024.         e = -e;
  1025.     for (i = 0;  e > 0;  i++, e /= 10)
  1026.         ;
  1027.     return(i);
  1028. }
  1029.  
  1030. fmt_exponent(e)
  1031. {
  1032.     if (e == 0) {
  1033.         writec_stream('0', fmt_stream);
  1034.         return;
  1035.     }
  1036.     if (e < 0)
  1037.         e = -e;
  1038.     fmt_exponent1(e);
  1039. }
  1040.     
  1041. fmt_exponent1(e)
  1042. {
  1043.     if (e == 0)
  1044.         return;
  1045.     fmt_exponent1(e/10);
  1046.     writec_stream('0' + e%10, fmt_stream);
  1047. }
  1048.  
  1049. fmt_exponential_float(colon, atsign)
  1050. {
  1051.     int w, d, e, k, overflowchar, padchar, exponentchar;
  1052.     double f;
  1053.     int sign;
  1054.     char buff[256], *b, buff1[256];
  1055.     int exp;
  1056.     int i, j;
  1057.     object x, y;
  1058.     int n, m;
  1059.     enum type t;
  1060.     vs_mark;
  1061.  
  1062.     b = buff1 + 1;
  1063.  
  1064.     fmt_not_colon(colon);
  1065.     fmt_max_param(7);
  1066.     fmt_set_param(0, &w, INT, 0);
  1067.     if (w < 0)
  1068.         fmt_error("illegal width");
  1069.     fmt_set_param(0, &w, INT, -1);
  1070.     fmt_set_param(1, &d, INT, 0);
  1071.     if (d < 0)
  1072.         fmt_error("illegal number of digits");
  1073.     fmt_set_param(1, &d, INT, -1);
  1074.     fmt_set_param(2, &e, INT, 0);
  1075.     if (e < 0)
  1076.         fmt_error("illegal number of digits in exponent");
  1077.     fmt_set_param(2, &e, INT, -1);
  1078.     fmt_set_param(3, &k, INT, 1);
  1079.     fmt_set_param(4, &overflowchar, CHAR, -1);
  1080.     fmt_set_param(5, &padchar, CHAR, ' ');
  1081.     fmt_set_param(6, &exponentchar, CHAR, -1);
  1082.  
  1083.     x = fmt_advance();
  1084.     if (type_of(x) == t_fixnum ||
  1085.         type_of(x) == t_bignum ||
  1086.         type_of(x) == t_ratio) {
  1087.         x = make_shortfloat((shortfloat)number_to_double(x));
  1088.         vs_push(x);
  1089.     }
  1090.     if (type_of(x) == t_complex) {
  1091.         if (w < 0)
  1092.             prin1(x, fmt_stream);
  1093.         else {
  1094.             fmt_nparam = 1;
  1095.             --fmt_index;
  1096.             fmt_decimal(colon, atsign);
  1097.         }
  1098.         vs_reset;
  1099.         return;
  1100.     }
  1101.     if (type_of(x) == t_longfloat)
  1102.         n = 16;
  1103.     else
  1104.         n = 7;
  1105.     f = number_to_double(x);
  1106.     edit_double(n, f, &sign, buff, &exp);
  1107.     if (d >= 0) {
  1108.         if (k > 0) {
  1109.             if (!(k < d + 2))
  1110.                 fmt_error("illegal scale factor");
  1111.             m = d + 1;
  1112.         } else {
  1113.             if (!(k > -d))
  1114.                 fmt_error("illegal scale factor");
  1115.             m = d + k;
  1116.         }
  1117.     } else if (w >= 0) {
  1118.         if (k > 0)
  1119.             m = w - 1;
  1120.         else
  1121.             m = w + k - 1;
  1122.         if (sign < 0 || atsign)
  1123.             --m;
  1124.         if (e >= 0)
  1125.             m -= e + 2;
  1126.         else
  1127.             m -= fmt_exponent_length(e - k + 1) + 2;
  1128.     } else
  1129.         m = n;
  1130.     if (m <= 0) {
  1131.         if (m == 0 && buff[0] >= '5') {
  1132.             exp++;
  1133.             n = m = 1;
  1134.             buff[0] = '1';
  1135.         } else
  1136.             n = m = 0;
  1137.     } else if (m < n) {
  1138.         n = m;
  1139.         edit_double(n, f, &sign, buff, &exp);
  1140.     }
  1141.     while (n >= 0)
  1142.         if (buff[n - 1] == '0')
  1143.             --n;
  1144.         else
  1145.             break;
  1146.     exp = exp - k + 1;
  1147.     j = 0;
  1148.     if (k > 0) {
  1149.         for (i = 0;  i < k;  i++)
  1150.             b[j++] = i < n ? buff[i] : '0';
  1151.         b[j++] = '.';
  1152.         if (d >= 0)
  1153.             for (m = i + (d - k + 1);  i < m;  i++)
  1154.                 b[j++] = i < n ? buff[i] : '0';
  1155.         else
  1156.             for (;  i < n;  i++)
  1157.                 b[j++] = buff[i];
  1158.     } else {
  1159.         b[j++] = '.';
  1160.         if (d >= 0) {
  1161.             for (i = 0;  i < -k && i < d;  i++)
  1162.                 b[j++] = '0';
  1163.             for (m = d - i, i = 0;  i < m;  i++)
  1164.                 b[j++] = i < n ? buff[i] : '0';
  1165.         } else if (n > 0) {
  1166.             for (i = 0;  i < -k;  i++)
  1167.                 b[j++] = '0';
  1168.             for (i = 0;  i < n;  i++)
  1169.                 b[j++] = buff[i];
  1170.         }
  1171.     }
  1172.     b[j] = '\0';
  1173.     if (w >= 0) {
  1174.         if (sign < 0 || atsign)
  1175.             --w;
  1176.         i = fmt_exponent_length(exp);
  1177.         if (e >= 0) {
  1178.             if (i > e) {
  1179.                 if (overflowchar >= 0)
  1180.                     goto OVER;
  1181.                 else
  1182.                     e = i;
  1183.             }
  1184.             w -= e + 2;
  1185.         } else
  1186.             w -= i + 2;
  1187.         if (j > w && overflowchar >= 0)
  1188.             goto OVER;
  1189.         if (j < w && b[j-1] == '.') {
  1190.             b[j++] = '0';
  1191.             b[j] = '\0';
  1192.         }
  1193.         if (j < w && b[0] == '.') {
  1194.             *--b = '0';
  1195.             j++;
  1196.         }
  1197.         for (i = j;  i < w;  i++)
  1198.             writec_stream(padchar, fmt_stream);
  1199.     } else {
  1200.         if (b[j-1] == '.') {
  1201.             b[j++] = '0';
  1202.             b[j] = '\0';
  1203.         }
  1204.         if (d < 0 && b[0] == '.') {
  1205.             *--b = '0';
  1206.             j++;
  1207.         }
  1208.     }
  1209.     if (sign < 0)
  1210.         writec_stream('-', fmt_stream);
  1211.     else if (atsign)
  1212.         writec_stream('+', fmt_stream);
  1213.     writestr_stream(b, fmt_stream);
  1214.     y = symbol_value(Vread_default_float_format);
  1215.     if (exponentchar < 0) {
  1216.         if (y == Slong_float || y == Sdouble_float)
  1217.             t = t_longfloat;
  1218.         else
  1219.             t = t_shortfloat;
  1220.         if (type_of(x) == t)
  1221.             exponentchar = 'E';
  1222.         else if (type_of(x) == t_shortfloat)
  1223.             exponentchar = 'S';
  1224.         else
  1225.             exponentchar = 'L';
  1226.     }
  1227.     writec_stream(exponentchar, fmt_stream);
  1228.     if (exp < 0)
  1229.         writec_stream('-', fmt_stream);
  1230.     else
  1231.         writec_stream('+', fmt_stream);
  1232.     if (e >= 0)
  1233.         for (i = e - fmt_exponent_length(exp);  i > 0;  --i)
  1234.             writec_stream('0', fmt_stream);
  1235.     fmt_exponent(exp);
  1236.     vs_reset;
  1237.     return;
  1238.  
  1239. OVER:
  1240.     fmt_set_param(0, &w, INT, -1);
  1241.     for (i = 0;  i < w;  i++)
  1242.         writec_stream(overflowchar, fmt_stream);
  1243.     vs_reset;
  1244.     return;
  1245. }
  1246.  
  1247. fmt_general_float(colon, atsign)
  1248. {
  1249.     int w, d, e, k, overflowchar, padchar, exponentchar;
  1250.     int sign, exp;
  1251.     char buff[256];
  1252.     object x;
  1253.     int n, ee, ww, q, dd;
  1254.     vs_mark;
  1255.  
  1256.     fmt_not_colon(colon);
  1257.     fmt_max_param(7);
  1258.     fmt_set_param(0, &w, INT, 0);
  1259.     if (w < 0)
  1260.         fmt_error("illegal width");
  1261.     fmt_set_param(0, &w, INT, -1);
  1262.     fmt_set_param(1, &d, INT, 0);
  1263.     if (d < 0)
  1264.         fmt_error("illegal number of digits");
  1265.     fmt_set_param(1, &d, INT, -1);
  1266.     fmt_set_param(2, &e, INT, 0);
  1267.     if (e < 0)
  1268.         fmt_error("illegal number of digits in exponent");
  1269.     fmt_set_param(2, &e, INT, -1);
  1270.     fmt_set_param(3, &k, INT, 1);
  1271.     fmt_set_param(4, &overflowchar, CHAR, -1);
  1272.     fmt_set_param(5, &padchar, CHAR, ' ');
  1273.     fmt_set_param(6, &exponentchar, CHAR, -1);
  1274.  
  1275.     x = fmt_advance();
  1276.     if (type_of(x) == t_complex) {
  1277.         if (w < 0)
  1278.             prin1(x, fmt_stream);
  1279.         else {
  1280.             fmt_nparam = 1;
  1281.             --fmt_index;
  1282.             fmt_decimal(colon, atsign);
  1283.         }
  1284.         vs_reset;
  1285.         return;
  1286.     }
  1287.     if (type_of(x) == t_longfloat)
  1288.         q = 16;
  1289.     else
  1290.         q = 7;
  1291.     edit_double(q, number_to_double(x), &sign, buff, &exp);
  1292.     n = exp + 1;
  1293.     while (q >= 0)
  1294.         if (buff[q - 1] == '0')
  1295.             --q;
  1296.         else
  1297.             break;
  1298.     if (e >= 0)
  1299.         ee = e + 2;
  1300.     else
  1301.         ee = 4;
  1302.     ww = w - ee;
  1303.     if (d < 0) {
  1304.         d = n < 7 ? n : 7;
  1305.         d = q > d ? q : d;
  1306.     }
  1307.     dd = d - n;
  1308.     if (0 <= dd && dd <= d) {
  1309.         fmt_nparam = 5;
  1310.         fmt_param[0].fmt_param_value = ww;
  1311.         fmt_param[1].fmt_param_value = dd;
  1312.         fmt_param[1].fmt_param_type = INT;
  1313.         fmt_param[2].fmt_param_type = NULL;
  1314.         fmt_param[3] = fmt_param[4];
  1315.         fmt_param[4] = fmt_param[5];
  1316.         --fmt_index;
  1317.         fmt_fix_float(colon, atsign);
  1318.         if (w >= 0)
  1319.             while (ww++ < w)
  1320.                 writec_stream(padchar, fmt_stream);
  1321.         vs_reset;
  1322.         return;
  1323.     }
  1324.     fmt_param[1].fmt_param_value = d;
  1325.     fmt_param[1].fmt_param_type = INT;
  1326.     --fmt_index;
  1327.     fmt_exponential_float(colon, atsign);
  1328.     vs_reset;
  1329. }
  1330.  
  1331. fmt_dollars_float(colon, atsign)
  1332. {
  1333.     int d, n, w, padchar;
  1334.     double f;
  1335.     int sign;
  1336.     char buff[256];
  1337.     int exp;
  1338.     int q, i;
  1339.     object x;
  1340.     vs_mark;
  1341.  
  1342.     fmt_max_param(4);
  1343.     fmt_set_param(0, &d, INT, 2);
  1344.     if (d < 0)
  1345.         fmt_error("illegal number of digits");
  1346.     fmt_set_param(1, &n, INT, 1);
  1347.     if (n < 0)
  1348.         fmt_error("illegal number of digits");
  1349.     fmt_set_param(2, &w, INT, 0);
  1350.     if (w < 0)
  1351.         fmt_error("illegal width");
  1352.     fmt_set_param(3, &padchar, CHAR, ' ');
  1353.     x = fmt_advance();
  1354.     if (type_of(x) == t_complex) {
  1355.         if (w < 0)
  1356.             prin1(x, fmt_stream);
  1357.         else {
  1358.             fmt_nparam = 1;
  1359.             fmt_param[0] = fmt_param[2];
  1360.             --fmt_index;
  1361.             fmt_decimal(colon, atsign);
  1362.         }
  1363.         vs_reset;
  1364.         return;
  1365.     }
  1366.     q = 7;
  1367.     if (type_of(x) == t_longfloat)
  1368.         q = 16;
  1369.     f = number_to_double(x);
  1370.     edit_double(q, f, &sign, buff, &exp);
  1371.     if ((q = exp + d + 1) > 0)
  1372.         edit_double(q, f, &sign, buff, &exp);
  1373.     exp++;
  1374.     if (w > 100 || exp > 100 || exp < -100) {
  1375.         fmt_nparam = 6;
  1376.         fmt_param[0] = fmt_param[2];
  1377.         fmt_param[1].fmt_param_value = d + n - 1;
  1378.         fmt_param[1].fmt_param_type = INT;
  1379.         fmt_param[2].fmt_param_type =
  1380.         fmt_param[3].fmt_param_type =
  1381.         fmt_param[4].fmt_param_type = NULL;
  1382.         fmt_param[5] = fmt_param[3];
  1383.         --fmt_index;
  1384.         fmt_exponential_float(colon, atsign);
  1385.     }
  1386.     if (exp > n)
  1387.         n = exp;
  1388.     if (sign < 0 || atsign)
  1389.         --w;
  1390.     if (colon) {
  1391.         if (sign < 0)
  1392.             writec_stream('-', fmt_stream);
  1393.         else if (atsign)
  1394.             writec_stream('+', fmt_stream);
  1395.         while (--w > n + d)
  1396.             writec_stream(padchar, fmt_stream);
  1397.     } else {
  1398.         while (--w > n + d)
  1399.             writec_stream(padchar, fmt_stream);
  1400.         if (sign < 0)
  1401.             writec_stream('-', fmt_stream);
  1402.         else if (atsign)
  1403.             writec_stream('+', fmt_stream);
  1404.     }
  1405.     for (i = n - exp;  i > 0;  --i)
  1406.         writec_stream('0', fmt_stream);
  1407.     for (i = 0;  i < exp;  i++)
  1408.         writec_stream((i < q ? buff[i] : '0'), fmt_stream);
  1409.     writec_stream('.', fmt_stream);
  1410.     for (d += i;  i < d;  i++)
  1411.         writec_stream((i < q ? buff[i] : '0'), fmt_stream);
  1412.     vs_reset;
  1413. }
  1414.  
  1415. fmt_percent(colon, atsign)
  1416. {
  1417.     int n, i;
  1418.  
  1419.     fmt_max_param(1);
  1420.     fmt_set_param(0, &n, INT, 1);
  1421.     fmt_not_colon(colon);
  1422.     fmt_not_atsign(atsign);
  1423.     while (n-- > 0) {
  1424.         writec_stream('\n', fmt_stream);
  1425.         if (n == 0)
  1426.             for (i = fmt_indents;  i > 0;  --i)
  1427.                 writec_stream(' ', fmt_stream);
  1428.     }
  1429. }
  1430.  
  1431. fmt_ampersand(colon, atsign)
  1432. {
  1433.     int n;
  1434.  
  1435.     fmt_max_param(1);
  1436.     fmt_set_param(0, &n, INT, 1);
  1437.     fmt_not_colon(colon);
  1438.     fmt_not_atsign(atsign);
  1439.     if (n == 0)
  1440.         return;
  1441.     if (file_column(fmt_stream) != 0)
  1442.         writec_stream('\n', fmt_stream);
  1443.     while (--n > 0)
  1444.         writec_stream('\n', fmt_stream);
  1445.     fmt_indents = 0;
  1446. }
  1447.  
  1448. fmt_bar(colon, atsign)
  1449. {
  1450.     int n;
  1451.  
  1452.     fmt_max_param(1);
  1453.     fmt_set_param(0, &n, INT, 1);
  1454.     fmt_not_colon(colon);
  1455.     fmt_not_atsign(atsign);
  1456.     while (n-- > 0)
  1457.         writec_stream('\f', fmt_stream);
  1458. }
  1459.  
  1460. fmt_tilde(colon, atsign)
  1461. {
  1462.     int n;
  1463.  
  1464.     fmt_max_param(1);
  1465.     fmt_set_param(0, &n, INT, 1);
  1466.     fmt_not_colon(colon);
  1467.     fmt_not_atsign(atsign);
  1468.     while (n-- > 0)
  1469.         writec_stream('~', fmt_stream);
  1470. }
  1471.  
  1472. fmt_newline(colon, atsign)
  1473. {
  1474.     int c;
  1475.  
  1476.     fmt_max_param(0);
  1477.     fmt_not_colon_atsign(colon, atsign);
  1478.     if (atsign)
  1479.         writec_stream('\n', fmt_stream);
  1480.     while (ctl_index < ctl_end && isspace(ctl_string[ctl_index])) {
  1481.         if (colon)
  1482.             writec_stream(ctl_string[ctl_index], fmt_stream);
  1483.         ctl_index++;
  1484.     }
  1485. }
  1486.  
  1487. fmt_tabulate(colon, atsign)
  1488. {
  1489.     int colnum, colinc;
  1490.     int c, i;
  1491.     
  1492.     fmt_max_param(2);
  1493.     fmt_not_colon(colon);
  1494.     fmt_set_param(0, &colnum, INT, 1);
  1495.     fmt_set_param(1, &colinc, INT, 1);
  1496.     if (!atsign) {
  1497.         c = file_column(fmt_stream);
  1498.         if (c < 0) {
  1499.             writestr_stream("  ", fmt_stream);
  1500.             return;
  1501.         }
  1502.         if (c > colnum && colinc <= 0)
  1503.             return;
  1504.         while (c > colnum)
  1505.             colnum += colinc;
  1506.         for (i = colnum - c;  i > 0;  --i)
  1507.             writec_stream(' ', fmt_stream);
  1508.     } else {
  1509.         for (i = colnum;  i > 0;  --i)
  1510.             writec_stream(' ', fmt_stream);
  1511.         c = file_column(fmt_stream);
  1512.         if (c < 0 || colinc <= 0)
  1513.             return;
  1514.         colnum = 0;
  1515.         while (c > colnum)
  1516.             colnum += colinc;
  1517.         for (i = colnum - c;  i > 0;  --i)
  1518.             writec_stream(' ', fmt_stream);
  1519.     }
  1520. }
  1521.  
  1522. fmt_asterisk(colon, atsign)
  1523. {
  1524.     int n;
  1525.  
  1526.     fmt_max_param(1);
  1527.     fmt_not_colon_atsign(colon, atsign);
  1528.     if (atsign) {
  1529.         fmt_set_param(0, &n, INT, 0);
  1530.         if (n < 0 || n >= fmt_end)
  1531.             fmt_error("can't goto");
  1532.         fmt_index = n;
  1533.     } else if (colon) {
  1534.         fmt_set_param(0, &n, INT, 1);
  1535.         if (n > fmt_index)
  1536.             fmt_error("can't back up");
  1537.         fmt_index -= n;
  1538.     } else {
  1539.         fmt_set_param(0, &n, INT, 1);
  1540.         while (n-- > 0)
  1541.             fmt_advance();
  1542.     }
  1543. }    
  1544.  
  1545. fmt_indirection(colon, atsign)
  1546. {
  1547.     object s, l;
  1548.     fmt_old;
  1549.     jmp_buf fmt_jmp_buf0;
  1550.     int up_colon;
  1551.  
  1552.     fmt_max_param(0);
  1553.     fmt_not_colon(colon);
  1554.     s = fmt_advance();
  1555.     if (type_of(s) != t_string)
  1556.         fmt_error("control string expected");
  1557.     if (atsign) {
  1558.         fmt_save;
  1559.         fmt_jmp_buf = fmt_jmp_buf0;
  1560.         fmt_string = s;
  1561.         if (up_colon = setjmp(fmt_jmp_buf)) {
  1562.             if (--up_colon)
  1563.                 fmt_error("illegal ~:^");
  1564.         } else
  1565.             format(fmt_stream, 0, s->st.st_fillp);
  1566.         fmt_restore1;
  1567.     } else {
  1568.         l = fmt_advance();
  1569.         fmt_save;
  1570.         fmt_base = vs_top;
  1571.         fmt_index = 0;
  1572.         for (fmt_end = 0;  !endp(l);  fmt_end++, l = l->c.c_cdr)
  1573.             vs_check_push(l->c.c_car);
  1574.         fmt_jmp_buf = fmt_jmp_buf0;
  1575.         fmt_string = s;
  1576.         if (up_colon = setjmp(fmt_jmp_buf)) {
  1577.             if (--up_colon)
  1578.                 fmt_error("illegal ~:^");
  1579.         } else
  1580.             format(fmt_stream, 0, s->st.st_fillp);
  1581.         vs_top = fmt_base;
  1582.         fmt_restore;
  1583.     }
  1584. }
  1585.  
  1586. fmt_case(colon, atsign)
  1587. {
  1588.     object x;
  1589.     int i, j;
  1590.     fmt_old;
  1591.     jmp_buf fmt_jmp_buf0;
  1592.     int up_colon;
  1593.     bool b;
  1594.  
  1595.     x = make_string_output_stream(64);
  1596.     vs_push(x);
  1597.     i = ctl_index;
  1598.     j = fmt_skip();
  1599.     if (ctl_string[--j] != ')' || ctl_string[--j] != '~')
  1600.         fmt_error("~) expected");
  1601.     fmt_save;
  1602.     fmt_jmp_buf = fmt_jmp_buf0;
  1603.     if (up_colon = setjmp(fmt_jmp_buf))
  1604.         ;
  1605.     else
  1606.         format(x, ctl_origin + i, j - i);
  1607.     fmt_restore1;
  1608.     x = x->sm.sm_object0;
  1609.     if (!colon && !atsign)
  1610.         for (i = 0;  i < x->st.st_fillp;  i++) {
  1611.             if (isUpper(j = x->st.st_self[i]))
  1612.                 j += 'a' - 'A';
  1613.             writec_stream(j, fmt_stream);
  1614.         }
  1615.     else if (colon && !atsign)
  1616.         for (b = TRUE, i = 0;  i < x->st.st_fillp;  i++) {
  1617.             if (isLower(j = x->st.st_self[i])) {
  1618.                 if (b)
  1619.                     j -= 'a' - 'A';
  1620.                 b = FALSE;
  1621.             } else if (isUpper(j)) {
  1622.                 if (!b)
  1623.                     j += 'a' - 'A';
  1624.                 b = FALSE;
  1625.             } else if (!isDigit(j))
  1626.                 b = TRUE;
  1627.             writec_stream(j, fmt_stream);
  1628.         }
  1629.     else if (!colon && atsign)
  1630.         for (b = TRUE, i = 0;  i < x->st.st_fillp;  i++) {
  1631.             if (isLower(j = x->st.st_self[i])) {
  1632.                 if (b)
  1633.                     j -= 'a' - 'A';
  1634.                 b = FALSE;
  1635.             } else if (isUpper(j)) {
  1636.                 if (!b)
  1637.                     j += 'a' - 'A';
  1638.                 b = FALSE;
  1639.             }
  1640.             writec_stream(j, fmt_stream);
  1641.         }
  1642.     else
  1643.         for (i = 0;  i < x->st.st_fillp;  i++) {
  1644.             if (isLower(j = x->st.st_self[i]))
  1645.                 j -= 'a' - 'A';
  1646.             writec_stream(j, fmt_stream);
  1647.         }
  1648.     vs_pop;
  1649.     if (up_colon)
  1650.         longjmp(fmt_jmp_buf, up_colon);
  1651. }
  1652.  
  1653. fmt_conditional(colon, atsign)
  1654. {
  1655.     int i, j, k;
  1656.     object x;
  1657.     int n;
  1658.     bool done;
  1659.     fmt_old;
  1660.  
  1661.     fmt_not_colon_atsign(colon, atsign);
  1662.     if (colon) {
  1663.         fmt_max_param(0);
  1664.         i = ctl_index;
  1665.         j = fmt_skip();
  1666.         if (ctl_string[--j] != ';' || ctl_string[--j] != '~')
  1667.             fmt_error("~; expected");
  1668.         k = fmt_skip();
  1669.         if (ctl_string[--k] != ']' || ctl_string[--k] != '~')
  1670.             fmt_error("~] expected");
  1671.         if (fmt_advance() == Cnil) {
  1672.             fmt_save;
  1673.             format(fmt_stream, ctl_origin + i, j - i);
  1674.             fmt_restore1;
  1675.         } else {
  1676.             fmt_save;
  1677.             format(fmt_stream, ctl_origin + j + 2, k - (j + 2));
  1678.             fmt_restore1;
  1679.         }
  1680.     } else if (atsign) {
  1681.         i = ctl_index;
  1682.         j = fmt_skip();
  1683.         if (ctl_string[--j] != ']' || ctl_string[--j] != '~')
  1684.             fmt_error("~] expected");
  1685.         if (fmt_advance() == Cnil)
  1686.             ;
  1687.         else {
  1688.             --fmt_index;
  1689.             fmt_save;
  1690.             format(fmt_stream, ctl_origin + i, j - i);
  1691.             fmt_restore1;
  1692.         }
  1693.     } else {
  1694.         fmt_max_param(1);
  1695.         if (fmt_nparam == 0) {
  1696.             x = fmt_advance();
  1697.             if (type_of(x) != t_fixnum)
  1698.                 fmt_error("illegal argument for conditional");
  1699.             n = fix(x);
  1700.         } else
  1701.             fmt_set_param(0, &n, INT, 0);
  1702.         i = ctl_index;
  1703.         for (done = FALSE;;  --n) {
  1704.             j = fmt_skip();
  1705.             for (k = j;  ctl_string[--k] != '~';)
  1706.                 ;
  1707.             if (n == 0) {
  1708.                 fmt_save;
  1709.                 format(fmt_stream, ctl_origin + i, k - i);
  1710.                 fmt_restore1;
  1711.                 done = TRUE;
  1712.             }
  1713.             i = j;
  1714.             if (ctl_string[--j] == ']') {
  1715.                 if (ctl_string[--j] != '~')
  1716.                     fmt_error("~] expected");
  1717.                 return;
  1718.             }
  1719.             if (ctl_string[j] == ';') {
  1720.                 if (ctl_string[--j] == '~')
  1721.                     continue;
  1722.                 if (ctl_string[j] == ':')
  1723.                     goto ELSE;
  1724.             }
  1725.             fmt_error("~; or ~] expected");
  1726.         }
  1727.     ELSE:
  1728.         if (ctl_string[--j] != '~')
  1729.             fmt_error("~:; expected");
  1730.         j = fmt_skip();
  1731.         if (ctl_string[--j] != ']' || ctl_string[--j] != '~')
  1732.             fmt_error("~] expected");
  1733.         if (!done) {
  1734.             fmt_save;
  1735.             format(fmt_stream, ctl_origin + i, j - i);
  1736.             fmt_restore1;
  1737.         }
  1738.     }
  1739. }    
  1740.  
  1741. fmt_iteration(colon, atsign)
  1742. {
  1743.     int n;
  1744.     int i, j;
  1745.     int o;
  1746.     bool colon_close = FALSE;
  1747.     object l, l0;
  1748.     fmt_old;
  1749.     jmp_buf fmt_jmp_buf0;
  1750.     int up_colon;
  1751.  
  1752.     fmt_max_param(1);
  1753.     fmt_set_param(0, &n, INT, 1000000);
  1754.     i = ctl_index;
  1755.     j = fmt_skip();
  1756.     if (ctl_string[--j] != '}')
  1757.         fmt_error("~} expected");
  1758.     if (ctl_string[--j] == ':') {
  1759.         colon_close = TRUE;
  1760.         --j;
  1761.     }
  1762.     if (ctl_string[j] != '~')
  1763.         fmt_error("syntax error");
  1764.     o = ctl_origin;
  1765.     if (!colon && !atsign) {
  1766.         l = fmt_advance();
  1767.         fmt_save;
  1768.         fmt_base = vs_top;
  1769.         fmt_index = 0;
  1770.         for (fmt_end = 0;  !endp(l);  fmt_end++, l = l->c.c_cdr)
  1771.             vs_check_push(l->c.c_car);
  1772.         fmt_jmp_buf = fmt_jmp_buf0;
  1773.         if (colon_close)
  1774.             goto L1;
  1775.         while (fmt_index < fmt_end) {
  1776.         L1:
  1777.             if (n-- <= 0)
  1778.                 break;
  1779.             if (up_colon = setjmp(fmt_jmp_buf)) {
  1780.                 if (--up_colon)
  1781.                     fmt_error("illegal ~:^");
  1782.                 break;
  1783.             }
  1784.             format(fmt_stream, o + i, j - i);
  1785.         }
  1786.         vs_top = fmt_base;
  1787.         fmt_restore;
  1788.     } else if (colon && !atsign) {
  1789.         l0 = fmt_advance();
  1790.         fmt_save;
  1791.         fmt_base = vs_top;
  1792.         fmt_jmp_buf = fmt_jmp_buf0;
  1793.         if (colon_close)
  1794.             goto L2;
  1795.         while (!endp(l0)) {
  1796.         L2:
  1797.             if (n-- <= 0)
  1798.                 break;
  1799.             l = l0->c.c_car;
  1800.             l0 = l0->c.c_cdr;
  1801.             fmt_index = 0;
  1802.             for (fmt_end = 0; !endp(l); fmt_end++, l = l->c.c_cdr)
  1803.                 vs_check_push(l->c.c_car);
  1804.             if (up_colon = setjmp(fmt_jmp_buf)) {
  1805.                 vs_top = fmt_base;
  1806.                 if (--up_colon)
  1807.                     break;
  1808.                 else
  1809.                     continue;
  1810.             }
  1811.             format(fmt_stream, o + i, j - i);
  1812.             vs_top = fmt_base;
  1813.         }
  1814.         fmt_restore;
  1815.     } else if (!colon && atsign) {
  1816.         fmt_save;
  1817.         fmt_jmp_buf = fmt_jmp_buf0;
  1818.         if (colon_close)
  1819.             goto L3;
  1820.         while (fmt_index < fmt_end) {
  1821.         L3:
  1822.             if (n-- <= 0)
  1823.                 break;
  1824.             if (up_colon = setjmp(fmt_jmp_buf)) {
  1825.                 if (--up_colon)
  1826.                     fmt_error("illegal ~:^");
  1827.                 break;
  1828.             }
  1829.             format(fmt_stream, o + i, j - i);
  1830.         }
  1831.         fmt_restore1;
  1832.     } else if (colon && atsign) {
  1833.         if (colon_close)
  1834.             goto L4;
  1835.         while (fmt_index < fmt_end) {
  1836.         L4:
  1837.             if (n-- <= 0)
  1838.                 break;
  1839.             l = fmt_advance();
  1840.             fmt_save;
  1841.             fmt_base = vs_top;
  1842.             fmt_index = 0;
  1843.             for (fmt_end = 0; !endp(l); fmt_end++, l = l->c.c_cdr)
  1844.                 vs_check_push(l->c.c_car);
  1845.             fmt_jmp_buf = fmt_jmp_buf0;
  1846.             if (up_colon = setjmp(fmt_jmp_buf)) {
  1847.                 vs_top = fmt_base;
  1848.                 fmt_restore;
  1849.                 if (--up_colon)
  1850.                     break;
  1851.                 else
  1852.                     continue;
  1853.             }
  1854.             format(fmt_stream, o + i, j - i);
  1855.             vs_top = fmt_base;
  1856.             fmt_restore;
  1857.         }
  1858.     }
  1859. }
  1860.  
  1861.  
  1862. fmt_justification(colon, atsign)
  1863. {
  1864.     int mincol, colinc, minpad, padchar;
  1865.     object fields[16];
  1866.     fmt_old;
  1867.     jmp_buf fmt_jmp_buf0;
  1868.     int i, j, k, l, m, n, j0, l0;
  1869.     int up_colon;
  1870.     int special = 0;
  1871.     int spare_spaces, line_length;
  1872.     vs_mark;
  1873.  
  1874.     fmt_max_param(4);
  1875.     fmt_set_param(0, &mincol, INT, 0);
  1876.     fmt_set_param(1, &colinc, INT, 1);
  1877.     fmt_set_param(2, &minpad, INT, 0);
  1878.     fmt_set_param(3, &padchar, CHAR, ' ');
  1879.  
  1880.     n = 0;
  1881.     for (;;) {
  1882.         if (n >= 16)
  1883.             fmt_error("too many fields");
  1884.         i = ctl_index;
  1885.         j0 = j = fmt_skip();
  1886.         while (ctl_string[--j] != '~')
  1887.             ;
  1888.         fields[n] = make_string_output_stream(64);
  1889.         vs_push(fields[n]);
  1890.         fmt_save;
  1891.         fmt_jmp_buf = fmt_jmp_buf0;
  1892.         if (up_colon = setjmp(fmt_jmp_buf)) {
  1893.             --n;
  1894.             if (--up_colon)
  1895.                 fmt_error("illegal ~:^");
  1896.             fmt_restore1;
  1897.             while (ctl_string[--j0] != '>')
  1898.                 j0 = fmt_skip();
  1899.             if (ctl_string[--j0] != '~')
  1900.                 fmt_error("~> expected");
  1901.             break;
  1902.         }
  1903.         format(fields[n++], ctl_origin + i, j - i);
  1904.         fmt_restore1;
  1905.         if (ctl_string[--j0] == '>') {
  1906.             if (ctl_string[--j0] != '~')
  1907.                 fmt_error("~> expected");
  1908.             break;
  1909.         } else if (ctl_string[j0] != ';')
  1910.             fmt_error("~; expected");
  1911.         else if (ctl_string[--j0] == ':') {
  1912.             if (n != 1)
  1913.                 fmt_error("illegal ~:;");
  1914.             special = 1;
  1915.             for (j = j0;  ctl_string[j] != '~';  --j)
  1916.                 ;
  1917.             fmt_save;
  1918.             format(fmt_stream, ctl_origin + j, j0 - j + 2);
  1919.             fmt_restore1;
  1920.             spare_spaces = fmt_spare_spaces;
  1921.             line_length = fmt_line_length;
  1922.         } else if (ctl_string[j0] != '~')
  1923.             fmt_error("~; expected");
  1924.     }
  1925.     for (i = special, l = 0;  i < n;  i++)
  1926.         l += fields[i]->sm.sm_object0->st.st_fillp;
  1927.     m = n - 1 - special;
  1928.     if (m <= 0 && !colon && !atsign) {
  1929.         m = 0;
  1930.         colon = TRUE;
  1931.     }
  1932.     if (colon)
  1933.         m++;
  1934.     if (atsign)
  1935.         m++;
  1936.     l0 = l;
  1937.     l += minpad * m;
  1938.     for (k = 0;  mincol + k * colinc < l;  k++)
  1939.         ;
  1940.     l = mincol + k * colinc;
  1941.     if (special != 0 &&
  1942.         file_column(fmt_stream) + l + spare_spaces >= line_length)
  1943.         princ(fields[0]->sm.sm_object0, fmt_stream);
  1944.     l -= l0;
  1945.     for (i = special;  i < n;  i++) {
  1946.         if (i > 0 || colon)
  1947.             for (j = l / m, l -= j, --m;  j > 0;  --j)
  1948.                 writec_stream(padchar, fmt_stream);
  1949.         princ(fields[i]->sm.sm_object0, fmt_stream);
  1950.     }
  1951.     if (atsign)
  1952.         for (j = l;  j > 0;  --j)
  1953.             writec_stream(padchar, fmt_stream);
  1954.     vs_reset;
  1955. }
  1956.  
  1957.  
  1958. fmt_up_and_out(colon, atsign)
  1959. {
  1960.     int i, j, k;
  1961.  
  1962.     fmt_max_param(3);
  1963.     fmt_not_atsign(atsign);
  1964.     if (fmt_nparam == 0) {
  1965.         if (fmt_index >= fmt_end)
  1966.             longjmp(fmt_jmp_buf, ++colon);
  1967.     } else if (fmt_nparam == 1) {
  1968.         fmt_set_param(0, &i, INT, 0);
  1969.         if (i == 0)
  1970.             longjmp(fmt_jmp_buf, ++colon);
  1971.     } else if (fmt_nparam == 2) {
  1972.         fmt_set_param(0, &i, INT, 0);
  1973.         fmt_set_param(1, &j, INT, 0);
  1974.         if (i == j)
  1975.             longjmp(fmt_jmp_buf, ++colon);
  1976.     } else {
  1977.         fmt_set_param(0, &i, INT, 0);
  1978.         fmt_set_param(1, &j, INT, 0);
  1979.         fmt_set_param(2, &k, INT, 0);
  1980.         if (i <= j && j <= k)
  1981.             longjmp(fmt_jmp_buf, ++colon);
  1982.     }
  1983. }
  1984.  
  1985.  
  1986. fmt_semicolon(colon, atsign)
  1987. {
  1988.     fmt_not_atsign(atsign);
  1989.     if (!colon)
  1990.         fmt_error("~:; expected");
  1991.     fmt_max_param(2);
  1992.     fmt_set_param(0, &fmt_spare_spaces, INT, 0);
  1993.     fmt_set_param(1, &fmt_line_length, INT, 72);
  1994. }
  1995.  
  1996.  
  1997. Lformat()
  1998. {
  1999.     object x = OBJNULL;
  2000.     jmp_buf fmt_jmp_buf0;
  2001.     bool colon, e;
  2002.     fmt_old;
  2003.  
  2004.     if (vs_top - vs_base < 2)
  2005.         too_few_arguments();
  2006.     if (vs_base[0] == Cnil) {
  2007.         vs_base[0] = make_string_output_stream(64);
  2008.         x = vs_base[0]->sm.sm_object0;
  2009.     } else if (vs_base[0] == Ct)
  2010.         vs_base[0] = symbol_value(Vstandard_output);
  2011.     else if (type_of(vs_base[0]) == t_string) {
  2012.         x = vs_base[0];
  2013.         if (!x->st.st_hasfillp)
  2014.           FEerror("The string ~S doesn't have a fill-pointer.", 1, x);
  2015.         vs_base[0] = make_string_output_stream(0);
  2016.         vs_base[0]->sm.sm_object0 = x;
  2017.     } else
  2018.         check_type_stream(&vs_base[0]);
  2019.     check_type_string(&vs_base[1]);
  2020.     fmt_save;
  2021.     frs_push(FRS_PROTECT, Cnil);
  2022.     if (nlj_active) {
  2023.         e = TRUE;
  2024.         goto L;
  2025.     }
  2026.     fmt_base = vs_base + 2;
  2027.     fmt_index = 0;
  2028.     fmt_end = vs_top - vs_base - 2;
  2029.     fmt_jmp_buf = fmt_jmp_buf0;
  2030.     if (symbol_value(siVindent_formatted_output) != Cnil)
  2031.         fmt_indents = file_column(vs_base[0]);
  2032.     else
  2033.         fmt_indents = 0;
  2034.     fmt_string = vs_base[1];
  2035.     if (colon = setjmp(fmt_jmp_buf)) {
  2036.         if (--colon)
  2037.             fmt_error("illegal ~:^");
  2038.         vs_base = vs_top;
  2039.         if (x != OBJNULL)
  2040.             vs_push(x);
  2041.         else
  2042.             vs_push(Cnil);
  2043.         e = FALSE;
  2044.         goto L;
  2045.     }
  2046.     format(vs_base[0], 0, vs_base[1]->st.st_fillp);
  2047.     flush_stream(vs_base[0]);
  2048.     vs_base = vs_top;
  2049.     if (x != OBJNULL)
  2050.         vs_push(x);
  2051.     else
  2052.         vs_push(Cnil);
  2053.     e = FALSE;
  2054. L:
  2055.     frs_pop();
  2056.     fmt_restore;
  2057.     if (e) {
  2058.         nlj_active = FALSE;
  2059.         unwind(nlj_fr, nlj_tag);
  2060.     }
  2061. }
  2062.  
  2063.  
  2064. fmt_error(s)
  2065. {
  2066.     vs_push(make_simple_string(s));
  2067.     vs_push(make_fixnum(&ctl_string[ctl_index] - fmt_string->st.st_self));
  2068.     FEerror("Format error: ~A.~%~V@TV~%\"~A\"~%",
  2069.         3, vs_top[-2], vs_top[-1], fmt_string);
  2070. }
  2071.  
  2072. init_format()
  2073. {
  2074.     fmt_temporary_stream = make_string_output_stream(64);
  2075.     enter_mark_origin(&fmt_temporary_stream);
  2076.     fmt_temporary_string = fmt_temporary_stream->sm.sm_object0;
  2077.  
  2078.     make_function("FORMAT", Lformat);
  2079.  
  2080.     siVindent_formatted_output
  2081.     = make_si_special("*INDENT-FORMATTED-OUTPUT*", Cnil);
  2082. }
  2083.